home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / mm.el < prev    next >
Encoding:
Text File  |  1995-08-31  |  42.3 KB  |  1,236 lines
  1. ;;; mm.el,v --- Mailcap parsing routines, and MIME handling
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/30 20:25:26
  4. ;; Version: 1.82
  5. ;; Keywords: mail, news, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;
  9. ;;; Copyright (c) 1994, 1995 by William M. Perry (wmperry@spry.com)
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  25. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26. ;;;
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; Generalized mailcap parsing and access routines
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;;
  31. ;;; Data structures
  32. ;;; ---------------
  33. ;;; The mailcap structure is an assoc list of assoc lists.
  34. ;;; 1st assoc list is keyed on the major content-type
  35. ;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp)
  36. ;;;
  37. ;;; Which looks like:
  38. ;;; -----------------
  39. ;;; (
  40. ;;;  ("application"
  41. ;;;   ("postscript" . <info>)
  42. ;;;  )
  43. ;;;  ("text"
  44. ;;;   ("plain" . <info>)
  45. ;;;  )
  46. ;;; )
  47. ;;;
  48. ;;; Where <info> is another assoc list of the various information
  49. ;;; related to the mailcap RFC.  This is keyed on the lowercase
  50. ;;; attribute name (viewer, test, etc).  This looks like:
  51. ;;; (("viewer" . viewerinfo)
  52. ;;;  ("test"   . testinfo)
  53. ;;;  ("xxxx"   . "string")
  54. ;;; )
  55. ;;;
  56. ;;; Where viewerinfo specifies how the content-type is viewed.  Can be
  57. ;;; a string, in which case it is run through a shell, with
  58. ;;; appropriate parameters, or a symbol, in which case the symbol is
  59. ;;; funcall'd, with the buffer as an argument.
  60. ;;;
  61. ;;; testinfo is a list of strings, or nil.  If nil, it means the
  62. ;;; viewer specified is always valid.  If it is a list of strings,
  63. ;;; these are used to determine whether a viewer passes the 'test' or
  64. ;;; not.
  65. ;;;
  66. ;;; The main interface to this code is:
  67. ;;;
  68. ;;; To set everything up:
  69. ;;;
  70. ;;;  (mm-parse-mailcaps [path])
  71. ;;;
  72. ;;;  Where PATH is a unix-style path specification (: separated list
  73. ;;;  of strings).  If PATH is nil, the environment variable MAILCAPS
  74. ;;;  will be consulted.  If there is no environment variable, then a
  75. ;;;  default list of paths is used.
  76. ;;;
  77. ;;; To retrieve the information:
  78. ;;;  (mm-mime-info st [nd] [request])
  79. ;;;
  80. ;;;  Where st and nd are positions in a buffer that contain the
  81. ;;;  content-type header information of a mail/news/whatever message.
  82. ;;;  st can optionally be a string that contains the content-type
  83. ;;;  information.
  84. ;;;
  85. ;;;  Third argument REQUEST specifies what information to return.  If
  86. ;;;  it is nil or the empty string, the viewer (second field of the
  87. ;;;  mailcap entry) will be returned.  If it is a string, then the
  88. ;;;  mailcap field corresponding to that string will be returned
  89. ;;;  (print, description, whatever).  If a number, then all the
  90. ;;;  information for this specific viewer is returned.
  91. ;;;
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. ;;; Variables, etc
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95. (defconst mm-version (let ((x "1.82"))
  96.                (if (string-match "Revision: \\([^ \t\n]+\\)" x)
  97.                (substring x (match-beginning 1) (match-end 1))
  98.              x))
  99.   "Version # of MM package")
  100.  
  101. (defvar mm-parse-args-syntax-table
  102.   (copy-syntax-table emacs-lisp-mode-syntax-table)
  103.   "A syntax table for parsing sgml attributes.")
  104.  
  105. (modify-syntax-entry ?' "\"" mm-parse-args-syntax-table)
  106. (modify-syntax-entry ?` "\"" mm-parse-args-syntax-table)
  107.  
  108. (defvar mm-mime-data
  109.   '(
  110.     ("multipart"   . (
  111.               ("alternative". (("viewer" . mm-multipart-viewer)
  112.                        ("type"   . "multipart/alternative")))
  113.               ("mixed"      . (("viewer" . mm-multipart-viewer)
  114.                        ("type"   . "multipart/mixed")))
  115.               (".*"         . (("viewer" . mm-save-binary-file)
  116.                        ("type"   . "multipart/*")))
  117.               )
  118.      )
  119.     ("application" . (
  120.               ("octet-stream" . (("viewer" . mm-save-binary-file)
  121.                      ("type" ."application/octet-stream")))
  122.               ("dvi"        . (("viewer" . "open %s")
  123.                        ("type"   . "application/dvi")
  124.                        ("test"   . (eq (device-type) 'ns))))
  125.               ("dvi"        . (("viewer" . "xdvi %s")
  126.                        ("needsx11")
  127.                        ("type"   . "application/dvi")))
  128.               ("dvi"        . (("viewer" . "dvitty %s")
  129.                        ("test"   . (not (getenv "DISPLAY")))
  130.                        ("type"   . "application/dvi")))
  131.               ("emacs-lisp" . (("viewer" . mm-maybe-eval)
  132.                        ("type"   . "application/emacs-lisp")))
  133. ;              ("x-tar"      . (("viewer" . tar-mode)
  134. ;                       ("test"   . (fboundp 'tar-mode))
  135. ;                       ("type"   . "application/x-tar")))
  136.               ("x-tar"      . (("viewer" . mm-save-binary-file)
  137.                        ("type"   . "application/x-tar")))
  138.               ("latex"      . (("viewer" . tex-mode)
  139.                        ("test"   . (fboundp 'tex-mode))
  140.                        ("type"   . "application/latex")))
  141.               ("tex"        . (("viewer" . tex-mode)
  142.                        ("test"   . (fboundp 'tex-mode))
  143.                        ("type"   . "application/tex")))
  144.               ("texinfo"    . (("viewer" . texinfo-mode)
  145.                        ("test"   . (fboundp 'texinfo-mode))
  146.                        ("type"   . "application/tex")))
  147.               ("x-gzip"     . (("viewer" . "gzip -dc %s")
  148.                        ("type"   . "application/x-gzip")
  149.                        ("copiousoutput")))
  150.                ("zip"        . (("viewer" . mm-save-binary-file)
  151.                         ("type"   . "application/zip")
  152.                         ("copiousoutput")))
  153.               ("pdf"        . (("viewer" . "acroread %s")
  154.                        ("type"   . "application/pdf")))
  155.               ("postscript" . (("viewer" . "open %s")
  156.                        ("type"   . "application/postscript")
  157.                        ("test"   . (eq (device-type) 'ns))))
  158.               ("postscript" . (("viewer" . "ghostview %s")
  159.                        ("type" . "application/postscript")
  160.                        ("needsx11")))
  161.               ("postscript" . (("viewer" . "ps2ascii %s")
  162.                        ("type" . "application/postscript")
  163.                        ("test" . (not (getenv "DISPLAY")))
  164.                        ("copiousoutput")))
  165.               ("x-www-pem-reply" .
  166.                (("viewer" . (w3-decode-pgp/pem "pem"))
  167.             ("test"   . (fboundp 'w3-decode-pgp/pem))
  168.             ("type"   . "application/x-www-pem-reply")
  169.             ))
  170.               ("x-www-pgp-reply" .
  171.                (("viewer" . (w3-decode-pgp/pem "pgp"))
  172.             ("test"   . (fboundp 'w3-decode-pgp/pem))
  173.             ("type" . "application/x-www-pgp-reply")))
  174.               ))
  175.     ("audio"       . (
  176.               ("x-mpeg" . (("viewer" . "maplay %s")
  177.                    ("type"   . "audio/x-mpeg")))
  178.               (".*" . (("viewer" . mm-play-sound-file)
  179.                    ("test"     . (or (featurep 'nas-sound)
  180.                            (featurep 'native-sound)))
  181.                    ("type"   . "audio/*")))
  182.               (".*" . (("viewer" . "showaudio")
  183.                    ("type"   . "audio/*")))
  184.               ))
  185.     ("message"     . (
  186.               ("rfc-*822" . (("viewer" . vm-mode)
  187.                      ("test"   . (fboundp 'vm-mode))
  188.                      ("type"   . "message/rfc-822")))
  189.               ("rfc-*822" . (("viewer" . w3-mode)
  190.                      ("test"   . (fboundp 'w3-mode))
  191.                      ("type"   . "message/rfc-822")))
  192.               ("rfc-*822" . (("viewer" . view-mode)
  193.                      ("test"   . (fboundp 'view-mode))
  194.                      ("type"   . "message/rfc-822")))
  195.               ("rfc-*822" . (("viewer" . fundamental-mode)
  196.                      ("type"   . "message/rfc-822")))
  197.               ))
  198.     ("image"       . (
  199.               ("x-xwd" . (("viewer"  . "xwud -in %s")
  200.                   ("type"    . "image/x-xwd")
  201.                   ("compose" . "xwd -frame > %s")
  202.                   ("needsx11")))
  203.               ("x11-dump" . (("viewer" . "xwud -in %s")
  204.                      ("type" . "image/x-xwd")
  205.                        ("compose" . "xwd -frame > %s")
  206.                      ("needsx11")))
  207.               ("windowdump" . (("viewer" . "xwud -in %s")
  208.                        ("type" . "image/x-xwd")
  209.                            ("compose" . "xwd -frame > %s")
  210.                        ("needsx11")))
  211.               (".*" . (("viewer" . "open %s")
  212.                    ("type"   . "image/*")
  213.                    ("test"   . (eq (device-type) 'ns))))
  214.               (".*" . (("viewer" . "xv -perfect %s")
  215.                    ("type" . "image/*")
  216.                    ("needsx11")))
  217.               ))
  218.     ("text"        . (
  219.               ("plain" . (("viewer"  . w3-mode)
  220.                   ("test"    . (fboundp 'w3-mode))
  221.                   ("type"    . "text/plain")))
  222.               ("plain" . (("viewer"  . view-mode)
  223.                   ("test"    . (fboundp 'view-mode))
  224.                   ("type"    . "text/plain")))
  225.               ("plain" . (("viewer"  . fundamental-mode)
  226.                   ("type"    . "text/plain")))
  227.               ("enriched" . (("viewer" . enriched-decode-region)
  228.                      ("test"   . (fboundp
  229.                           'enriched-decode-region))
  230.                      ("type"   . "text/enriched")))
  231.               ("html"  . (("viewer" . w3-prepare-buffer)
  232.                   ("test"   . (fboundp 'w3-prepare-buffer))
  233.                   ("type"   . "text/html")))
  234.               ))
  235.     ("video"       . (
  236.               ("mpeg" . (("viewer" . "mpeg_play %s")
  237.                  ("type"   . "video/mpeg")
  238.                  ("needsx11")))
  239.               ))
  240.     ("x-world"     . (
  241.               ("x-vrml" . (("viewer"  . "webspace -remote %s -URL %u")
  242.                    ("type"    . "x-world/x-vrml")
  243.                    ("description"
  244.                     "VRML document")))))
  245.           
  246.  
  247.     ("archive"     . (
  248.               ("tar"  . (("viewer" . tar-mode)
  249.                  ("type" . "archive/tar")
  250.                  ("test" . (fboundp 'tar-mode))))
  251.               ))
  252.     )
  253.   "*The mailcap structure is an assoc list of assoc lists.
  254. 1st assoc list is keyed on the major content-type
  255. 2nd assoc list is keyed on the minor content-type (which can be a regexp)
  256.  
  257. Which looks like:
  258. -----------------
  259. (
  260.  (\"application\"
  261.   (\"postscript\" . <info>)
  262.  )
  263.  (\"text\"
  264.   (\"plain\" . <info>)
  265.  )
  266. )
  267.  
  268. Where <info> is another assoc list of the various information
  269. related to the mailcap RFC.  This is keyed on the lowercase
  270. attribute name (viewer, test, etc).  This looks like:
  271. ((\"viewer\" . viewerinfo)
  272.  (\"test\"   . testinfo)
  273.  (\"xxxx\"   . \"string\")
  274. )
  275.  
  276. Where viewerinfo specifies how the content-type is viewed.  Can be
  277. a string, in which case it is run through a shell, with
  278. appropriate parameters, or a symbol, in which case the symbol is
  279. funcall'd, with the buffer as an argument.
  280.  
  281. testinfo is a list of strings, or nil.  If nil, it means the
  282. viewer specified is always valid.  If it is a list of strings,
  283. these are used to determine whether a viewer passes the 'test' or
  284. not.")
  285.  
  286. (defvar mm-content-transfer-encodings
  287.   '(("base64"     . base64-decode)
  288.     ("x-gzip"     . ("gzip" "-dc"))
  289.     ("7bit"       . ignore)
  290.     ("8bit"       . ignore)
  291.     ("binary"     . ignore)
  292.     ("x-compress" . ("uncompress" "-c"))
  293.     ("x-hqx"      . ("mcvert" "-P" "-s" "-S"))
  294.     ("quoted-printable" . mm-decode-quoted-printable)
  295.     )
  296.   "*An assoc list of content-transfer-encodings and how to decode them.")
  297.  
  298. (defvar mm-download-directory nil
  299.   "*Where downloaded files should go by default.")
  300.  
  301. (defvar mm-temporary-directory "/tmp"
  302.   "*Where temporary files go.")
  303.  
  304.  
  305. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  306. ;;; A few things from w3 and url, just in case this is used without them
  307. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  308. (if (boundp 'MULE)
  309.     (defun mm-insert-file-contents (filename &rest args)
  310.       (let ((file-coding-system-for-read *noconv*))
  311.         (insert-file-contents filename args)))
  312.   (fset 'mm-insert-file-contents 'insert-file-contents))
  313.  
  314. (defun mm-generate-unique-filename (&optional fmt)
  315.   "Generate a unique filename in mm-temporary-directory"
  316.   (if (not fmt)
  317.       (let ((base (format "mm-tmp.%d" (user-real-uid)))
  318.         (fname "")
  319.         (x 0))
  320.     (setq fname (format "%s%d" base x))
  321.     (while (file-exists-p
  322.         (expand-file-name fname mm-temporary-directory))
  323.       (setq x (1+ x)
  324.         fname (concat base (int-to-string x))))
  325.     (expand-file-name fname mm-temporary-directory))
  326.     (let ((base (concat "mm" (int-to-string (user-real-uid))))
  327.       (fname "")
  328.       (x 0))
  329.       (setq fname (format fmt (concat base (int-to-string x))))
  330.       (while (file-exists-p
  331.           (expand-file-name fname mm-temporary-directory))
  332.     (setq x (1+ x)
  333.           fname (format fmt (concat base (int-to-string x)))))
  334.       (expand-file-name fname mm-temporary-directory))))
  335.  
  336. (if (not (fboundp 'copy-tree))
  337.     (defun copy-tree (tree)
  338.       (if (consp tree)
  339.       (cons (copy-tree (car tree))
  340.         (copy-tree (cdr tree)))
  341.     (if (vectorp tree)
  342.         (let* ((new (copy-sequence tree))
  343.            (i (1- (length new))))
  344.           (while (>= i 0)
  345.         (aset new i (copy-tree (aref new i)))
  346.         (setq i (1- i)))
  347.           new)
  348.       tree))))
  349.  
  350. (if (not (fboundp 'w3-save-binary-file))
  351.     (defun mm-save-binary-file ()
  352.       (let ((x (read-file-name "Filename to save as: "
  353.                    (or mm-download-directory "~/"))))
  354.     (save-excursion
  355.       (if (boundp 'MULE)
  356.           (let ((mc-flag t))
  357.         (write-region (point-min) (point-max) x nil nil *noconv*))
  358.         (write-region (point-min) (point-max) x))
  359.       (kill-buffer (current-buffer)))))
  360.   (fset 'mm-save-binary-file 'w3-save-binary-file))
  361.  
  362. (if (not (fboundp 'w3-maybe-eval))
  363.     (defun mm-maybe-eval ()
  364.       "Maybe evaluate a buffer of emacs lisp code"
  365.       (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
  366.       (eval-buffer (current-buffer))
  367.     (emacs-lisp-mode)))
  368.   (fset 'mm-maybe-eval 'w3-maybe-eval))
  369.  
  370.  
  371. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  372. ;;; The mailcap parser
  373. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  374. (defun mm-in-assoc (elt list)
  375.   ;; Check to see if ELT matches any of the regexps in the car elements of LIST
  376.   (let (rslt)
  377.     (while (and list (not rslt))
  378.       (and (car (car list))
  379.        (string-match (car (car list)) elt)
  380.        (setq rslt (car list)))
  381.       (setq list (cdr list)))
  382.     rslt))
  383.  
  384. (defun mm-replace-regexp (regexp to-string)
  385.   ;; Quiet replace-regexp.
  386.   (goto-char (point-min))
  387.   (while (re-search-forward regexp nil t)
  388.     (replace-match to-string t nil)))
  389.  
  390. (defun mm-parse-mailcaps (&optional path)
  391.   ;; Parse out all the mailcaps specified in a unix-style path string PATH
  392.   (cond
  393.    (path nil)
  394.    ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
  395.    ((memq system-type '(ms-dos ms-windows windows-nt))
  396.     (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
  397.               ";")))
  398.    (t (setq path (concat "/etc/mailcap:/usr/etc/mailcap:"
  399.              "/usr/local/etc/mailcap:"
  400.              (expand-file-name "~/.mailcap")))))
  401.   (let ((fnames (mm-string-to-tokens path
  402.                      (if (memq system-type
  403.                            '(ms-dos ms-windows windows-nt))
  404.                      ?;
  405.                        ?:))) fname)
  406.     (while fnames
  407.       (setq fname (car fnames))
  408.       (if (and (file-exists-p fname) (file-readable-p fname))
  409.       (mm-parse-mailcap (car fnames)))
  410.       (setq fnames (cdr fnames)))))
  411.  
  412. (defun mm-parse-mailcap (fname)
  413.   ;; Parse out the mailcap file specified by FNAME
  414.   (let (major                ; The major mime type (image/audio/etc)
  415.     minor                ; The minor mime type (gif, basic, etc)
  416.     save-pos            ; Misc saved positions used in parsing
  417.     viewer                ; How to view this mime type
  418.     info                ; Misc info about this mime type
  419.     )
  420.     (save-excursion
  421.       (set-buffer (get-buffer-create " *mailcap*"))
  422.       (erase-buffer)
  423.       (mm-insert-file-contents fname)
  424.       (set-syntax-table mm-parse-args-syntax-table)
  425.       (mm-replace-regexp "#.*" "")             ; Remove all comments
  426.       (mm-replace-regexp "\n+" "\n")         ; And blank lines
  427.       (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
  428.       (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
  429.       (goto-char (point-max))
  430.       (skip-chars-backward " \t\n")
  431.       (delete-region (point) (point-max))
  432.       (goto-char (point-min))
  433.       (while (not (eobp))
  434.     (skip-chars-forward " \t\n")
  435.     (setq save-pos (point)
  436.           info nil)
  437.     (skip-chars-forward "^/;")
  438.     (downcase-region save-pos (point))
  439.     (setq major (buffer-substring save-pos (point)))
  440.     (skip-chars-forward "/ \t\n")
  441.     (setq save-pos (point))
  442.     (skip-chars-forward "^;")
  443.     (downcase-region save-pos (point))
  444.     (setq minor
  445.           (cond
  446.            ((= ?* (or (char-after save-pos) 0)) ".*")
  447.            ((= (point) save-pos) ".*")
  448.            (t (buffer-substring save-pos (point)))))
  449.     (skip-chars-forward "; \t\n")
  450.     ;;; Got the major/minor chunks, now for the viewers/etc
  451.     ;;; The first item _must_ be a viewer, according to the
  452.     ;;; RFC for mailcap files (#1343)
  453.     (skip-chars-forward "; \t\n")
  454.     (setq save-pos (point))
  455.     (skip-chars-forward "^;\n")
  456.     (if (= (or (char-after save-pos) 0) ?')
  457.         (setq viewer (progn
  458.                (narrow-to-region (1+ save-pos) (point))
  459.                (goto-char (point-min))
  460.                (prog1
  461.                    (read (current-buffer))
  462.                  (goto-char (point-max))
  463.                  (widen))))
  464.       (setq viewer (buffer-substring save-pos (point))))
  465.     (setq save-pos (point))
  466.     (end-of-line)
  467.     (setq info (nconc (list (cons "viewer" viewer)
  468.                 (cons "type" (concat major "/"
  469.                              (if (string= minor ".*")
  470.                              "*" minor))))
  471.               (mm-parse-mailcap-extras save-pos (point))))
  472.     (mm-mailcap-entry-passes-test info)
  473.     (mm-add-mailcap-entry major minor info)))))
  474.  
  475. (defun mm-parse-mailcap-extras (st nd)
  476.   ;; Grab all the extra stuff from a mailcap entry
  477.   (let (
  478.     name                ; From name=
  479.     value                ; its value
  480.     results                ; Assoc list of results
  481.     name-pos            ; Start of XXXX= position
  482.     val-pos                ; Start of value position
  483.     done                ; Found end of \'d ;s?
  484.     )
  485.     (save-restriction
  486.       (narrow-to-region st nd)
  487.       (goto-char (point-min))
  488.       (skip-chars-forward " \n\t;")
  489.       (while (not (eobp))
  490.     (setq done nil)
  491.     (skip-chars-forward " \";\n\t")
  492.     (setq name-pos (point))
  493.     (skip-chars-forward "^ \n\t=")
  494.     (downcase-region name-pos (point))
  495.     (setq name (buffer-substring name-pos (point)))
  496.     (skip-chars-forward " \t\n")
  497.     (if (/= (or (char-after (point)) 0)  ?=) ; There is no value
  498.         (setq value nil)
  499.       (skip-chars-forward " \t\n=")
  500.       (setq val-pos (point))
  501.       (if (memq (char-after val-pos) '(?\" ?'))
  502.           (progn
  503.         (setq val-pos (1+ val-pos))
  504.         (condition-case nil
  505.             (progn
  506.               (forward-sexp 1)
  507.               (backward-char 1))
  508.           (error (goto-char (point-max)))))
  509.         (while (not done)
  510.           (skip-chars-forward "^;")
  511.           (if (= (or (char-after (1- (point))) 0) ?\\ )
  512.           (progn
  513.             (subst-char-in-region (1- (point)) (point) ?\\ ? )
  514.             (skip-chars-forward ";"))
  515.         (setq done t))))
  516.       (setq    value (buffer-substring val-pos (point))))
  517.     (setq results (cons (cons name value) results)))
  518.       results)))  
  519.  
  520. (defun mm-string-to-tokens (str &optional delim)
  521.   "Return a list of words from the string STR"
  522.   (setq delim (or delim ? ))
  523.   (let (results y)
  524.     (mapcar
  525.      (function
  526.       (lambda (x)
  527.     (cond
  528.      ((and (= x delim) y) (setq results (cons y results) y nil))
  529.      ((/= x delim) (setq y (concat y (char-to-string x))))
  530.      (t nil)))) str)
  531.     (nreverse (cons y results))))
  532.  
  533. (defun mm-mailcap-entry-passes-test (info)
  534.   ;; Return t iff a mailcap entry passes its test clause or no test
  535.   ;; clause is present.
  536.   (let (status                ; Call-process-regions return value
  537.     (test (assoc "test" info)); The test clause
  538.     )
  539.     (setq status (and test (mm-string-to-tokens (cdr test))))
  540.     (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
  541.     (setq status nil)
  542.       (cond
  543.        ((and (equal (nth 0 status) "test")
  544.          (equal (nth 1 status) "-n")
  545.          (or (equal (nth 2 status) "$DISPLAY")
  546.          (equal (nth 2 status) "\"$DISPLAY\"")))
  547.     (setq status (if (getenv "DISPLAY") t nil)))
  548.        ((and (equal (nth 0 status) "test")
  549.          (equal (nth 1 status) "-z")
  550.          (or (equal (nth 2 status) "$DISPLAY")
  551.          (equal (nth 2 status) "\"$DISPLAY\"")))
  552.     (setq status (if (getenv "DISPLAY") nil t)))
  553.        (test nil)
  554.        (t nil)))
  555.     (and test (listp test) (setcdr test status))))
  556.  
  557. (defun mm-parse-args (st &optional nd allow-math)
  558.   ;; Return an assoc list of attribute/value pairs from an RFC822-type string
  559.   (let (
  560.     name                ; From name=
  561.     value                ; its value
  562.     results                ; Assoc list of results
  563.     name-pos            ; Start of XXXX= position
  564.     val-pos                ; Start of value position
  565.     math                ; what math was done
  566.     )
  567.     (save-excursion
  568.       (if (stringp st)
  569.       (progn
  570.         (set-buffer (get-buffer-create " *mm-temp*"))
  571.         (set-syntax-table mm-parse-args-syntax-table)
  572.         (erase-buffer)
  573.         (insert st)
  574.         (setq st (point-min)
  575.           nd (point-max)))
  576.     (set-syntax-table mm-parse-args-syntax-table))
  577.       (save-restriction
  578.     (narrow-to-region st nd)
  579.     (goto-char (point-min))
  580.     (while (not (eobp))
  581.       (skip-chars-forward "; \n\t")
  582.       (setq name-pos (point))
  583.       (skip-chars-forward "^ \n\t=;")
  584.       (downcase-region name-pos (point))
  585.       (setq name (buffer-substring name-pos (point)))
  586.       (skip-chars-forward " \t\n")
  587.       (if (if (not allow-math)
  588.           (/= (or (char-after (point)) 0)  ?=) ; There is no value
  589.         (not (memq (char-after (point)) '(?= ?* ?+ ?- ?/))))
  590.           (setq value nil)
  591.         (setq math (and allow-math
  592.                 (memq (char-after (point)) '(?* ?+ ?- ?/))
  593.                 (char-after (point))))
  594.         (if (not allow-math)
  595.         (skip-chars-forward " \t\n=")
  596.           (skip-chars-forward "^=")
  597.           (skip-chars-forward " \t\n="))
  598.         (setq val-pos (point)
  599.           value
  600.           (cond
  601.            ((or (= (or (char-after val-pos) 0) ?\")
  602.             (= (or (char-after val-pos) 0) ?'))
  603.             (buffer-substring (1+ val-pos)
  604.                       (condition-case ()
  605.                       (prog2
  606.                           (forward-sexp 1)
  607.                           (1- (point))
  608.                         (skip-chars-forward "\""))
  609.                     (error
  610.                      (skip-chars-forward "^ \t\n")
  611.                      (point)))))
  612.            (t
  613.             (buffer-substring val-pos
  614.                       (progn
  615.                     (skip-chars-forward "^;")
  616.                     (skip-chars-backward " \t")
  617.                     (point)))))))
  618.       (setq results (cons (if math
  619.                   (cons name (cons math value))
  620.                 (cons name value)) results)))
  621.     results))))
  622.  
  623. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  624. ;;; The action routines.
  625. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  626. (defun mm-possible-viewers (major minor)
  627.   ;; Return a list of possible viewers from MAJOR for minor type MINOR
  628.   (let ((exact '())
  629.     (wildcard '()))
  630.     (while major
  631.       (cond
  632.        ((equal (car (car major)) minor)
  633.     (setq exact (cons (cdr (car major)) exact)))
  634.        ((string-match (car (car major)) minor)
  635.     (setq wildcard (cons (cdr (car major)) wildcard))))
  636.       (setq major (cdr major)))
  637.     (nconc (nreverse exact) (nreverse wildcard))))
  638.  
  639. (defun mm-unescape-mime-test (test type-info)
  640.   (let ((buff (get-buffer-create " *unescape*"))
  641.     save-pos save-chr subst)
  642.     (cond
  643.      ((symbolp test) test)
  644.      ((and (listp test) (symbolp (car test))) test)
  645.      ((or (stringp test)
  646.       (and (listp test) (stringp (car test))
  647.            (setq test (mapconcat 'identity test " "))))
  648.       (save-excursion
  649.     (set-buffer buff)
  650.     (erase-buffer)
  651.     (insert test)
  652.     (goto-char (point-min))
  653.     (while (not (eobp))
  654.       (skip-chars-forward "^%")
  655.       (if (/= (- (point)
  656.              (progn (skip-chars-backward "\\\\")
  657.                 (point)))
  658.           0) ; It is an escaped %
  659.           (progn
  660.         (delete-char 1)
  661.         (skip-chars-forward "%."))
  662.         (setq save-pos (point))
  663.         (skip-chars-forward "%")
  664.         (setq save-chr (char-after (point)))
  665.         (cond
  666.          ((null save-chr) nil)
  667.          ((= save-chr ?t)
  668.           (delete-region save-pos (progn (forward-char 1) (point)))
  669.           (insert (or (cdr (assoc "type" type-info)) "\"\"")))
  670.          ((= save-chr ?M)
  671.           (delete-region save-pos (progn (forward-char 1) (point)))
  672.           (insert "\"\""))
  673.          ((= save-chr ?n)
  674.           (delete-region save-pos (progn (forward-char 1) (point)))
  675.           (insert "\"\""))
  676.          ((= save-chr ?F)
  677.           (delete-region save-pos (progn (forward-char 1) (point)))
  678.           (insert "\"\""))
  679.          ((= save-chr ?{)
  680.           (forward-char 1)
  681.           (skip-chars-forward "^}")
  682.           (downcase-region (+ 2 save-pos) (point))
  683.           (setq subst (buffer-substring (+ 2 save-pos) (point)))
  684.           (delete-region save-pos (1+ (point)))
  685.           (insert (or (cdr (assoc subst type-info)) "\"\"")))
  686.          (t nil))))
  687.     (buffer-string)))
  688.      (t (error "Bad value to mm-unescape-mime-test. %s" test)))))
  689.  
  690. (defun mm-viewer-passes-test (viewer-info type-info)
  691.   ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
  692.   ;; test clause (if any).
  693.   (let* ((test-info   (assoc "test"   viewer-info))
  694.      (test (cdr test-info))
  695.      (viewer (cdr (assoc "viewer" viewer-info)))
  696.      status
  697.      parsed-test
  698.     )
  699.     (cond
  700.      ((not test-info) t)        ; No test clause
  701.      ((not test) nil)            ; Already failed test
  702.      ((eq test t) t)            ; Already passed test
  703.      ((and (symbolp test)        ; Lisp function as test
  704.        (fboundp test))
  705.       (funcall test type-info))
  706.      ((and (symbolp test)        ; Lisp variable as test
  707.        (boundp test))
  708.       (symbol-value test))
  709.      ((and (listp test)            ; List to be eval'd
  710.        (symbolp (car test)))
  711.       (eval test))
  712.      (t
  713.       (setq test (mm-unescape-mime-test test type-info)
  714.         test (list "/bin/sh" nil nil nil "-c" test)
  715.         status (apply 'call-process test))
  716.       (= 0 status)))))
  717.  
  718. (defun mm-add-mailcap-entry (major minor info)
  719.   (let ((old-major (assoc major mm-mime-data)))
  720.     (if (null old-major)        ; New major area
  721.     (setq mm-mime-data
  722.           (cons (cons major (list (cons minor info)))
  723.             mm-mime-data))
  724.       (let ((cur-minor (assoc minor old-major)))
  725.     (cond
  726.      ((or (null cur-minor)        ; New minor area, or
  727.           (assoc "test" info))    ; Has a test, insert at beginning
  728.       (setcdr old-major (cons (cons minor info) (cdr old-major))))
  729.      ((and (not (assoc "test" info)); No test info, replace completely
  730.            (not (assoc "test" cur-minor)))
  731.       (setcdr cur-minor info))
  732.      (t
  733.       (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
  734.  
  735.  
  736. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  737. ;;; The main whabbo
  738. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  739. (defun mm-viewer-lessp (x y)
  740.   ;; Return t iff viewer X is more desirable than viewer Y
  741.   (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) "")))
  742.     (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) "")))
  743.     (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) ""))))
  744.     (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) "")))))
  745.     (cond
  746.      ((and x-lisp (not y-lisp))
  747.       t)
  748.      ((and (not y-lisp) x-wild (not y-wild))
  749.       t)
  750.      ((and (not x-wild) y-wild)
  751.       t)
  752.      (t nil))))
  753.  
  754. (defun mm-mime-info (st &optional nd request)
  755.   "Get the mime viewer command for HEADERLINE, return nil if none found.
  756. Expects a complete content-type header line as its argument.  This can
  757. be simple like text/html, or complex like text/plain; charset=blah; foo=bar
  758.  
  759. Third argument REQUEST specifies what information to return.  If it is
  760. nil or the empty string, the viewer (second field of the mailcap
  761. entry) will be returned.  If it is a string, then the mailcap field
  762. corresponding to that string will be returned (print, description,
  763. whatever).  If a number, then all the information for this specific
  764. viewer is returned."
  765.   (let (
  766.     major                ; Major encoding (text, etc)
  767.     minor                ; Minor encoding (html, etc)
  768.     info                ; Other info
  769.     save-pos            ; Misc. position during parse
  770.     major-info            ; (assoc major mm-mime-data)
  771.     minor-info            ; (assoc minor major-info)
  772.     test                ; current test proc.
  773.     viewers                ; Possible viewers
  774.     passed                ; Viewers that passed the test
  775.     viewer                ; The one and only viewer
  776.     )
  777.     (save-excursion
  778.       (cond
  779.        ((null st)
  780.     (set-buffer (get-buffer-create " *mimeparse*"))
  781.     (erase-buffer)
  782.     (insert "text/plain")
  783.     (setq st (point-min)))
  784.        ((stringp st)
  785.     (set-buffer (get-buffer-create " *mimeparse*"))
  786.     (erase-buffer)
  787.     (insert st)
  788.     (setq st (point-min)))
  789.        ((null nd)
  790.     (narrow-to-region st (progn (goto-char st) (end-of-line) (point))))
  791.        (t (narrow-to-region st nd)))
  792.       (goto-char st)
  793.       (skip-chars-forward ": \t\n")
  794.       (buffer-enable-undo)
  795.       (setq viewer
  796.         (catch 'mm-exit
  797.           (setq save-pos (point))
  798.           (skip-chars-forward "^/")
  799.           (downcase-region save-pos (point))
  800.           (setq major (buffer-substring save-pos (point)))
  801.           (if (not (setq major-info (cdr (assoc major mm-mime-data))))
  802.           (throw 'mm-exit nil))
  803.           (skip-chars-forward "/ \t\n")
  804.           (setq save-pos (point))
  805.           (skip-chars-forward "^ \t\n;")
  806.           (downcase-region save-pos (point))
  807.           (setq minor (buffer-substring save-pos (point)))
  808.           (if (not
  809.            (setq viewers (mm-possible-viewers major-info minor)))
  810.           (throw 'mm-exit nil))
  811.           (skip-chars-forward "; \t")
  812.           (if (eolp)
  813.           nil                ; No qualifiers
  814.         (setq save-pos (point))
  815.         (end-of-line)
  816.         (setq info (mm-parse-args save-pos (point)))
  817.         )
  818.           (while viewers
  819.         (if (mm-viewer-passes-test (car viewers) info)
  820.             (setq passed (cons (car viewers) passed)))
  821.         (setq viewers (cdr viewers)))
  822.           (setq passed (sort (nreverse passed) 'mm-viewer-lessp))
  823.           (car passed)))
  824.       (if (and (stringp (cdr (assoc "viewer" viewer)))
  825.            passed)
  826.       (setq viewer (car passed)))
  827.       (widen)
  828.       (cond
  829.        ((and (null viewer) (not (equal major "default")))
  830.     (mm-mime-info "default" nil request))
  831.        ((or (null request) (equal request ""))
  832.     (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info))
  833.        ((stringp request)
  834.     (if (or (string= request "test") (string= request "viewer"))
  835.         (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
  836.        (t
  837.     ;; MUST make a copy *sigh*, else we modify mm-mime-data
  838.     (setq viewer (copy-tree viewer))
  839.     (let ((view (assoc "viewer" viewer))
  840.           (test (assoc "test" viewer)))
  841.       (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))
  842.       (if test (setcdr test (mm-unescape-mime-test (cdr test) info))))
  843.     viewer)))))
  844.  
  845.  
  846. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  847. ;;; Experimental MIME-types parsing
  848. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  849. (defvar mm-mime-extensions
  850.   '(
  851.     (""          . "text/plain")
  852.     (".abs"      . "audio/x-mpeg")
  853.     (".aif"      . "audio/aiff")
  854.     (".aifc"     . "audio/aiff")
  855.     (".aiff"     . "audio/aiff")
  856.     (".ano"      . "application/x-annotator")
  857.     (".au"       . "audio/ulaw")
  858.     (".avi"      . "video/x-msvideo")
  859.     (".bcpio"    . "application/x-bcpio")
  860.     (".bin"      . "application/octet-stream")
  861.     (".cdf"      . "application/x-netcdr")
  862.     (".cpio"     . "application/x-cpio")
  863.     (".csh"      . "application/x-csh")
  864.     (".dvi"      . "application/x-dvi")
  865.     (".el"       . "application/emacs-lisp")
  866.     (".eps"      . "application/postscript")
  867.     (".etx"      . "text/x-setext")
  868.     (".exe"      . "application/octet-stream")
  869.     (".fax"      . "image/x-fax")
  870.     (".gif"      . "image/gif")
  871.     (".hdf"      . "application/x-hdf")
  872.     (".hqx"      . "application/mac-binhex40")
  873.     (".htm"      . "text/html")
  874.     (".html"     . "text/html")
  875.     (".icon"     . "image/x-icon")
  876.     (".ief"      . "image/ief")
  877.     (".jpg"      . "image/jpeg")
  878.     (".macp"     . "image/x-macpaint")
  879.     (".man"      . "application/x-troff-man")
  880.     (".me"       . "application/x-troff-me")
  881.     (".mif"      . "application/mif")
  882.     (".mov"      . "video/quicktime")
  883.     (".movie"    . "video/x-sgi-movie")
  884.     (".mp2"      . "audio/x-mpeg")
  885.     (".mp2a"     . "audio/x-mpeg2")
  886.     (".mpa"      . "audio/x-mpeg")
  887.     (".mpa2"     . "audio/x-mpeg2")
  888.     (".mpe"      . "video/mpeg")
  889.     (".mpeg"     . "video/mpeg")
  890.     (".mpega"    . "audio/x-mpeg")
  891.     (".mpegv"    . "video/mpeg")
  892.     (".mpg"      . "video/mpeg")
  893.     (".mpv"      . "video/mpeg")
  894.     (".ms"       . "application/x-troff-ms")
  895.     (".nc"       . "application/x-netcdf")
  896.     (".nc"       . "application/x-netcdf")
  897.     (".oda"      . "application/oda")
  898.     (".pbm"      . "image/x-portable-bitmap")
  899.     (".pdf"      . "application/pdf")
  900.     (".pgm"      . "image/portable-graymap")
  901.     (".pict"     . "image/pict")
  902.     (".pnm"      . "image/x-portable-anymap")
  903.     (".ppm"      . "image/portable-pixmap")
  904.     (".ps"       . "application/postscript")
  905.     (".qt"       . "video/quicktime")
  906.     (".ras"      . "image/x-raster")
  907.     (".rgb"      . "image/x-rgb")
  908.     (".rtf"      . "application/rtf")
  909.     (".rtx"      . "text/richtext")
  910.     (".sh"       . "application/x-sh")
  911.     (".sit"      . "application/x-stuffit")
  912.     (".snd"      . "audio/basic")
  913.     (".src"      . "application/x-wais-source")
  914.     (".tar"      . "archive/tar")
  915.     (".tcl"      . "application/x-tcl")
  916.     (".tcl"      . "application/x-tcl")
  917.     (".tex"      . "application/tex")
  918.     (".texi"     . "application/texinfo")
  919.     (".tga"      . "image/x-targa")
  920.     (".tif"      . "image/tiff")
  921.     (".tiff"     . "image/tiff")
  922.     (".tr"       . "application/x-troff")
  923.     (".troff"    . "application/x-troff")
  924.     (".tsv"      . "text/tab-separated-values")
  925.     (".txt"      . "text/plain")
  926.     (".vbs"      . "video/mpeg")
  927.     (".vox"      . "audio/basic")
  928.     (".vrml"     . "x-world/x-vrml")
  929.     (".wav"      . "audio/x-wav")
  930.     (".wrl"      . "x-world/x-vrml")
  931.     (".xbm"      . "image/xbm")
  932.     (".xpm"      . "image/x-pixmap")
  933.     (".xwd"      . "image/windowdump")
  934.     (".zip"      . "application/zip")
  935.     (".ai"       . "application/postscript")
  936.     (".jpe"      . "image/jpeg")
  937.     (".jpeg"     . "image/jpeg")
  938.     )
  939.   "*An assoc list of file extensions and the MIME content-types they
  940. correspond to.")
  941.  
  942. (defun mm-parse-mimetypes (&optional path)
  943.   ;; Parse out all the mimetypes specified in a unix-style path string PATH
  944.   (cond
  945.    (path nil)
  946.    ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
  947.    ((memq system-type '(ms-dos ms-windows windows-nt))
  948.     (setq path (mapconcat 'expand-file-name
  949.               '("~/mime.typ" "~/etc/mime.typ") ";")))
  950.    (t (setq path (concat (expand-file-name "~/.mime-types") ":"
  951.              "/etc/mime-types:/usr/etc/mime-types:"
  952.              "/usr/local/etc/mime-types:"
  953.              "/usr/local/www/conf/mime-types"))))
  954.   (let ((fnames (mm-string-to-tokens path
  955.                      (if (memq system-type
  956.                            '(ms-dos ms-windows windows-nt))
  957.                      ?;
  958.                        ?:))) fname)
  959.     (while fnames
  960.       (setq fname (car fnames))
  961.       (if (and (file-exists-p fname) (file-readable-p fname))
  962.       (mm-parse-mimetype-file (car fnames)))
  963.       (setq fnames (cdr fnames)))))
  964.  
  965. (defun mm-parse-mimetype-file (fname)
  966.   ;; Parse out a mime-types file
  967.   (let (type                ; The MIME type for this line
  968.     extns                ; The extensions for this line
  969.     save-pos            ; Misc. saved buffer positions
  970.     )
  971.     (save-excursion
  972.       (set-buffer (get-buffer-create " *mime-types*"))
  973.       (erase-buffer)
  974.       (mm-insert-file-contents fname)
  975.       (mm-replace-regexp "#.*" "")
  976.       (mm-replace-regexp "\n+" "\n")
  977.       (mm-replace-regexp "[ \t]+$" "")
  978.       (goto-char (point-max))
  979.       (skip-chars-backward " \t\n")
  980.       (delete-region (point) (point-max))
  981.       (goto-char (point-min))
  982.       (while (not (eobp))
  983.     (skip-chars-forward " \t\n")
  984.     (setq save-pos (point))
  985.     (skip-chars-forward "^ \t")
  986.     (downcase-region save-pos (point))
  987.     (setq type (buffer-substring save-pos (point)))
  988.     (while (not (eolp))
  989.       (skip-chars-forward " \t")
  990.       (setq save-pos (point))
  991.       (skip-chars-forward "^ \t\n")
  992.       (setq extns (cons (buffer-substring save-pos (point)) extns)))
  993.     (while extns
  994.       (setq mm-mime-extensions
  995.         (cons
  996.          (cons (if (= (string-to-char (car extns)) ?.)
  997.                (car extns)
  998.              (concat "." (car extns))) type) mm-mime-extensions)
  999.         extns (cdr extns)))))))
  1000.  
  1001. (defun mm-extension-to-mime (extn)
  1002.   "Return the MIME content type of the file extensions EXTN"
  1003.   (if (and (stringp extn)
  1004.        (not (= (string-to-char extn) ?.)))
  1005.       (setq extn (concat "." extn)))
  1006.   (cdr (assoc (downcase extn) mm-mime-extensions)))
  1007.  
  1008.  
  1009. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1010. ;;; Editing/Composition of body parts
  1011. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1012. (defun mm-compose-type (type)
  1013.   ;; Compose a body section of MIME-type TYPE.
  1014.   (let* ((info (mm-mime-info type nil 5))
  1015.      (fnam (mm-generate-unique-filename))
  1016.      (comp (or (cdr (assoc "compose" info))))
  1017.      (ctyp (cdr (assoc "composetyped" info)))
  1018.      (buff (get-buffer-create " *mimecompose*"))
  1019.      (typeit (not ctyp))
  1020.      (retval "")
  1021.      (usef nil))
  1022.     (setq comp (mm-unescape-mime-test (or comp ctyp) info))
  1023.     (while (string-match "\\([^\\\\]\\)%s" comp)
  1024.       (setq comp (concat (substring comp 0 (match-end 1)) fnam
  1025.              (substring comp (match-end 0) nil))
  1026.         usef t))
  1027.     (call-process (or shell-file-name
  1028.               (getenv "ESHELL") (getenv "SHELL") "/bin/sh")
  1029.           nil (if usef nil buff) nil "-c" comp)
  1030.     (setq retval
  1031.       (concat
  1032.        (if typeit (concat "Content-type: " type "\r\n\r\n") "")
  1033.        (if usef
  1034.            (save-excursion
  1035.          (set-buffer buff)
  1036.          (erase-buffer)
  1037.          (mm-insert-file-contents fnam)
  1038.          (buffer-string))
  1039.          (save-excursion
  1040.            (set-buffer buff)
  1041.            (buffer-string)))
  1042.        "\r\n"))
  1043.     retval))    
  1044.  
  1045. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1046. ;;; Misc.
  1047. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1048. (defun mm-type-to-file (type)
  1049.   "Return the file extension for content-type TYPE"
  1050.   (rassoc type mm-mime-extensions))
  1051.  
  1052.  
  1053. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1054. ;;; Miscellaneous MIME viewers written in elisp
  1055. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1056. (defun mm-play-sound-file (&optional buff)
  1057.   "Play a sound file in buffer BUFF (defaults to current buffer)"
  1058.   (setq buff (or buff (current-buffer)))
  1059.   (let ((fname (mm-generate-unique-filename "%s.au"))
  1060.     (synchronous-sounds t))        ; Play synchronously
  1061.     (if (boundp 'MULE)
  1062.     (write-region (point-min) (point-max) fname nil nil *noconv*)
  1063.       (write-region (point-min) (point-max) fname))
  1064.     (kill-buffer (current-buffer))
  1065.     (play-sound-file fname)
  1066.     (condition-case ()
  1067.     (delete-file fname)
  1068.       (error nil))))
  1069.     
  1070. (defun mm-parse-mime-headers (&optional no-delete)
  1071.   "Return a list of the MIME headers at the top of this buffer.  If
  1072. optional argument NO-DELETE is non-nil, don't delete the headers."
  1073.   (let* ((st (point-min))
  1074.      (nd (progn
  1075.            (goto-char (point-min))
  1076.            (skip-chars-forward " \t\n")
  1077.            (if (re-search-forward "^\r*$" nil t)
  1078.            (1+ (point))
  1079.          (point-max))))
  1080.      save-pos
  1081.      status
  1082.      hname
  1083.      hvalu
  1084.      result
  1085.      )
  1086.     (narrow-to-region st nd)
  1087.     (goto-char (point-min))
  1088.     (while (not (eobp))
  1089.       (skip-chars-forward " \t\n\r")
  1090.       (setq save-pos (point))
  1091.       (skip-chars-forward "^:\n\r")
  1092.       (downcase-region save-pos (point))
  1093.       (setq hname (buffer-substring save-pos (point)))
  1094.       (skip-chars-forward ": \t ")
  1095.       (setq save-pos (point))
  1096.       (skip-chars-forward "^\n\r")
  1097.       (setq hvalu (buffer-substring save-pos (point))
  1098.         result (cons (cons hname hvalu) result)))
  1099.     (or no-delete (delete-region st nd))
  1100.     result))
  1101.  
  1102. (defun mm-find-available-multiparts (separator &optional buf)
  1103.   "Return a list of mime-headers for the various body parts of a 
  1104. multipart message in buffer BUF with separator SEPARATOR.
  1105. The different multipart specs are put in `mm-temporary-directory'."
  1106.   (let ((sep (concat "^--" separator "\r*$"))
  1107.     headers
  1108.     fname
  1109.     results)
  1110.     (save-excursion
  1111.       (and buf (set-buffer buf))
  1112.       (goto-char (point-min))
  1113.       (while (re-search-forward sep nil t)
  1114.     (let ((st (set-marker (make-marker)
  1115.                   (progn
  1116.                 (forward-line 1)
  1117.                 (beginning-of-line)
  1118.                 (point))))
  1119.           (nd (set-marker (make-marker)
  1120.                   (if (re-search-forward sep nil t)
  1121.                   (1- (match-beginning 0))
  1122.                 (point-max)))))
  1123.       (narrow-to-region st nd)
  1124.       (goto-char st)
  1125.       (if (looking-at "^\r*$")
  1126.           (insert "Content-type: text/plain\n"
  1127.               "Content-length: " (int-to-string (- nd st)) "\n"))
  1128.       (setq headers (mm-parse-mime-headers)
  1129.         fname (mm-generate-unique-filename))
  1130.       (let ((x (or (cdr (assoc "content-type" headers)) "text/plain")))
  1131.         (if (string-match "name=\"*\\([^ \"]+\\)\"*" x)
  1132.         (setq fname (expand-file-name
  1133.                  (substring x (match-beginning 1)
  1134.                     (match-end 1))
  1135.                  mm-temporary-directory))))
  1136.       (widen)
  1137.       (if (assoc "content-transfer-encoding" headers)
  1138.           (let ((coding (cdr
  1139.                  (assoc "content-transfer-encoding" headers)))
  1140.             (cmd nil))
  1141.         (setq coding (and coding (downcase coding))
  1142.               cmd (or (cdr (assoc coding
  1143.                       mm-content-transfer-encodings))
  1144.                   (read-string
  1145.                    (concat "How shall I decode " coding "? ")
  1146.                    "cat")))
  1147.         (if (string= cmd "") (setq cmd "cat"))
  1148.         (if (stringp cmd)
  1149.             (shell-command-on-region st nd cmd t)
  1150.           (funcall cmd st nd))
  1151.         (set-marker nd (point))))
  1152.       (write-region st nd fname nil 5)
  1153.       (delete-region st nd)
  1154.       (setq results (cons
  1155.              (cons
  1156.               (cons "mm-filename" fname) headers) results)))))
  1157.     results))
  1158.  
  1159. (defun mm-format-multipart-as-html (&optional buf type)
  1160.   (if buf (set-buffer buf))
  1161.   (let* ((boundary (if (string-match
  1162.             "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)"
  1163.             type)
  1164.                (regexp-quote
  1165.             (substring type (match-beginning 1) (match-end 1)))))
  1166.      (parts    (mm-find-available-multiparts boundary)))
  1167.     (erase-buffer)
  1168.     (insert "<html>\n"
  1169.         " <head>\n"
  1170.         "  <title>Multipart Message</title>\n"
  1171.         " </head>\n"
  1172.         " <body>\n"
  1173.         "   <h1> Multipart message encountered </h1>\n"
  1174.         "   <p> I have encountered a multipart MIME message.\n"
  1175.         "       The following parts have been detected.  Please\n"
  1176.         "       select which one you want to view.\n"
  1177.         "   </p>\n"
  1178.         "   <ul>\n"
  1179.         (mapconcat 
  1180.          (function (lambda (x)
  1181.              (concat "    <li> <a href=\"file:"
  1182.                  (cdr (assoc "mm-filename" x))
  1183.                  "\">"
  1184.                  (or (cdr (assoc "content-description" x)) "")
  1185.                  "--"
  1186.                  (or (cdr (assoc "content-type" x))
  1187.                      "unknown type")
  1188.                  "</a> </li>")))
  1189.          parts "\n")
  1190.         "   </ul>\n"
  1191.         " </body>\n"
  1192.         "</html>\n"
  1193.         "<!-- Automatically generated by MM v" mm-version "-->\n")))
  1194.  
  1195. (defun mm-multipart-viewer ()
  1196.   (mm-format-multipart-as-html
  1197.    (current-buffer)
  1198.    (cdr (assoc "content-type" url-current-mime-headers)))
  1199.   (let ((w3-working-buffer (current-buffer)))
  1200.     (w3-prepare-buffer)))
  1201.  
  1202. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1203. ;;; Transfer encodings we can decrypt automatically
  1204. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1205. (defun mm-decode-quoted-printable (&optional st nd)
  1206.   (interactive)
  1207.   (setq st (or st (point-min))
  1208.     nd (or nd (point-max)))
  1209.   (save-restriction
  1210.     (narrow-to-region st nd)
  1211.     (save-excursion
  1212.       (let ((buffer-read-only nil))
  1213.     (goto-char (point-min))
  1214.     (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t)
  1215.       (replace-match 
  1216.        (char-to-string 
  1217.         (+
  1218.          (* 16 (mm-hex-char-to-integer 
  1219.             (char-after (1+ (match-beginning 0)))))
  1220.          (mm-hex-char-to-integer
  1221.           (char-after (1- (match-end 0))))))))))))
  1222.  
  1223. ;; Taken from hexl.el.
  1224. (defun mm-hex-char-to-integer (character)
  1225.   "Take a char and return its value as if it was a hex digit."
  1226.   (if (and (>= character ?0) (<= character ?9))
  1227.       (- character ?0)
  1228.     (let ((ch (logior character 32)))
  1229.       (if (and (>= ch ?a) (<= ch ?f))
  1230.       (- ch (- ?a 10))
  1231.     (error (format "Invalid hex digit `%c'." ch))))))
  1232.  
  1233.  
  1234. (require 'base64)
  1235. (provide 'mm)
  1236.